home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / uim / look.scm < prev    next >
Encoding:
Text File  |  2010-11-07  |  19.9 KB  |  577 lines
  1. ;;;
  2. ;;; Copyright (c) 2003-2009 uim Project http://code.google.com/p/uim/
  3. ;;;
  4. ;;; All rights reserved.
  5. ;;;
  6. ;;; Redistribution and use in source and binary forms, with or without
  7. ;;; modification, are permitted provided that the following conditions
  8. ;;; are met:
  9. ;;; 1. Redistributions of source code must retain the above copyright
  10. ;;;    notice, this list of conditions and the following disclaimer.
  11. ;;; 2. Redistributions in binary form must reproduce the above copyright
  12. ;;;    notice, this list of conditions and the following disclaimer in the
  13. ;;;    documentation and/or other materials provided with the distribution.
  14. ;;; 3. Neither the name of authors nor the names of its contributors
  15. ;;;    may be used to endorse or promote products derived from this software
  16. ;;;    without specific prior written permission.
  17. ;;;
  18. ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
  19. ;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  20. ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21. ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
  22. ;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23. ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  24. ;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  25. ;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  26. ;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  27. ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  28. ;;; SUCH DAMAGE.
  29. ;;;;
  30.  
  31. (require-custom "generic-key-custom.scm")
  32. (require-custom "look-custom.scm")
  33.  
  34. ;; widgets
  35. (define look-widgets '(widget_look_input_mode))
  36.  
  37. ;; default activity for each widgets
  38. (define default-widget_look_input_mode 'action_look_sleep)
  39.  
  40. ;; actions of widget_look_input_mode
  41. (define look-input-mode-actions
  42.   '(action_look_sleep action_look_direct action_look_look))
  43.  
  44. ;;; implementations
  45.  
  46. (register-action 'action_look_sleep
  47.                  (lambda (lc)
  48.                    (list
  49.                     'look_sleep_input
  50.                     "_"
  51.                     (N_ "Sleep")
  52.                     (N_ "Look Sleep Input Mode")))
  53.                  (lambda (lc)
  54.                    (not (look-context-on? lc)))
  55.                  (lambda (lc)
  56.                    (look-context-set-on! lc #f)))
  57.  
  58. (register-action 'action_look_direct
  59.                  (lambda (lc)
  60.                    (list
  61.                     'look_direct_input
  62.                     "-"
  63.                     (N_ "Direct")
  64.                     (N_ "Look Direct Input Mode")))
  65.                  (lambda (lc)
  66.                    (and (look-context-on? lc)
  67.                         (not (look-context-look? lc))))
  68.                  (lambda (lc)
  69.                    (look-context-set-on! lc #t)
  70.                    (look-context-set-look! lc #f)))
  71.  
  72. (register-action 'action_look_look
  73.                  (lambda (lc)
  74.                    (list
  75.                     'look_input
  76.                     "e" ;; do you like nethack?
  77.                     (N_ "Look")
  78.                     (N_ "Look Input Mode")))
  79.                  (lambda (lc)
  80.                    (and (look-context-on? lc)
  81.                         (look-context-look? lc)))
  82.                  (lambda (lc)
  83.                    (look-context-set-on! lc #t)
  84.                    (look-context-set-look! lc #t)))
  85.  
  86. ;; Update widget definitions based on action configurations. The
  87. ;; procedure is needed for on-the-fly reconfiguration involving the
  88. ;; custom API
  89. (define (look-configure-widgets)
  90.   (register-widget 'widget_look_input_mode
  91.                    (activity-indicator-new look-input-mode-actions)
  92.                    (actions-new look-input-mode-actions)))
  93.  
  94. (define look-context-rec-spec
  95.   (append
  96.    context-rec-spec
  97.    (list
  98.     (list 'on         #f)
  99.     (list 'look       #f)
  100.     (list 'nth        0)
  101.     (list 'candidates ())
  102.     (list 'left       "")
  103.     (list 'prev       ())    ; simple queue: ([string]prevword1 prevword2 ...)
  104.     (list 'dict       #f)    ; list ((([string]prevword1 prevword2 ...)  . [alist]history) ...)
  105.     (list 'dictlen    0))))
  106. (define look-context-rec-spec look-context-rec-spec)
  107. (define-record 'look-context look-context-rec-spec)
  108. (define look-context-new-internal look-context-new)
  109.  
  110. ;; XXX: fake R5RS functions
  111. (define (look-internal:string->list s)
  112.   (map (lambda (c)
  113.          (string->symbol c))
  114.        (reverse (string-to-list s))))
  115. (define (look-internal:list->string l)
  116.   (apply string-append
  117.          (map (lambda (x)
  118.                 (symbol->string x))
  119.               l)))
  120. (define (look-internal:make-string n c)
  121.   (apply string-append (map (lambda (x) (symbol->string c)) (iota n))))
  122. ;; XXX: slow quick-sort
  123. (define (look-internal:qsort! data proc)
  124.   (let ((pivot 0)
  125.         (left '())
  126.         (right '()))
  127.     (if (< (length data) 2)
  128.         data
  129.         (begin
  130.           (set! pivot (car data))
  131.           (for-each (lambda (x)
  132.                       (if (proc x pivot)
  133.                           (set! left (cons x left ))
  134.                           (set! right (cons x right))))
  135.                     (cdr data))
  136.           (append (look-internal:qsort! left proc) (cons pivot (look-internal:qsort! right proc)))))))
  137. (define (look-to-lower-string str)
  138.   (apply string-append
  139.          (map (lambda (c)
  140.                 (if (ichar-upper-case? (string->charcode c))
  141.                     (charcode->string (ichar-downcase (string->charcode c)))
  142.                     c))
  143.               (reverse (string-to-list str)))))
  144.  
  145. (define (look-history-sort li lessf)
  146.   ;;(map car li))
  147.   (map car (look-internal:qsort!
  148.             li
  149.             (lambda (x y) (lessf (cdr x) (cdr y))))))
  150.  
  151. (define (look-history-eow? x)
  152.   (eq? #t (car x)))
  153. (define (look-init-history seedf)
  154.   (list (cons #t (seedf))))
  155. (define (look-make-eow stat)
  156.   (cons #t stat))
  157. (define (look-histroy-append str hist seedf eowf)
  158.   (let ((cs (look-internal:string->list str)))
  159.     (cond ((null? cs)
  160.            (if (assq #t hist) ; eow?
  161.                (map (lambda (x)
  162.                       (if (look-history-eow? x)
  163.                           (look-make-eow (eowf (cdr x)))
  164.                           x))
  165.                     hist)
  166.                (append (list (look-make-eow (seedf))) hist)))
  167.           ((and (not (null? hist))
  168.                 (assoc (car cs) hist))
  169.            (map (lambda (x)
  170.                   (if (equal? (car cs) (car x))
  171.                       (cons (car cs)
  172.                             (look-histroy-append
  173.                              (look-internal:list->string (cdr cs))
  174.                              (cdr x)
  175.                              seedf eowf))
  176.                       x))
  177.                 hist))
  178.           (else
  179.            (append (list (cons (car cs)
  180.                                (look-histroy-append
  181.                                 (look-internal:list->string (cdr cs))
  182.                                 '()
  183.                                 seedf eowf)))
  184.                    hist)))))
  185. (define (look-history-search str hist)
  186.   (define (skip str hist)
  187.     (let ((cs (look-internal:string->list str)))
  188.       (if (null? cs)
  189.           hist
  190.           (let ((c (assoc (car cs) hist)))
  191.             (if c
  192.                 (skip (look-internal:list->string (cdr cs)) (cdr c))
  193.                 '())))))
  194.   (define (connect-tree hist)
  195.     (let loop ((hist hist) (rest ""))
  196.       (cond ((null? hist)
  197.              '())
  198.             ((find (lambda (x) (not (look-history-eow? x))) hist)
  199.              (apply
  200.               append (map (lambda (l)
  201.                             (let ((li (loop (cdr l)
  202.                                             (string-append rest (look-internal:make-string 1 (car l))))))
  203.                               (if (list? li)
  204.                                   li
  205.                                   (list li))))
  206.                           (filter (lambda (x) (not (look-history-eow? x))) hist))))
  207.             (else
  208.              (cons rest (cdar hist))))))
  209.   (connect-tree (filter (lambda (x) (not (look-history-eow? x)))
  210.                         (skip str hist))))
  211.  
  212. ;; accumulator
  213. (define (look-history-stat-init)
  214.   1)
  215. (define (look-history-stat-inc x)
  216.   (+ 1 x))
  217. (define (look-history-stat-less x y)
  218.   (> x y))
  219.  
  220. ;; XXX: non-atomic functions
  221. (define (look-save-personal-dict lc)
  222.   (call-with-output-file look-personal-dict-filename
  223.     (lambda (port)
  224.       (im-clear-preedit lc)
  225.       (im-pushback-preedit
  226.        lc preedit-reverse
  227.        "[saving...]")
  228.       (im-update-preedit lc)
  229.       (write (cons look-prepared-words
  230.                    (look-context-dict lc))
  231.              port)
  232.       (im-clear-preedit lc)
  233.       (im-update-preedit lc))))
  234.  
  235. (define (look-load-personal-dict lc)
  236.   (if (file-readable? look-personal-dict-filename)
  237.       (let ((dict (call-with-input-file look-personal-dict-filename
  238.             (lambda (port)
  239.               (im-clear-preedit lc)
  240.               (im-pushback-preedit
  241.                lc preedit-reverse
  242.                "[loading...]")
  243.               (im-update-preedit lc)
  244.               (guard (err
  245.                   (else #f))
  246.             (read port))))))
  247.     (if (and dict
  248.          (not (null? dict))
  249.          (= (car dict) look-prepared-words))
  250.         (look-context-set-dict! lc (cdr dict)))))
  251.   (im-clear-preedit lc)
  252.   (im-update-preedit lc))
  253.  
  254. (define (look-learn lc)
  255.   (define (histroy-append hist)
  256.     (look-histroy-append (look-to-lower-string (look-context-left lc))
  257.                          hist
  258.                          look-history-stat-init
  259.                          look-history-stat-inc))
  260.   (cond ((= 0 look-prepared-words)
  261.          (let ((hist (if (not (look-context-dict lc))
  262.                          (look-init-history look-history-stat-init)
  263.                          (look-context-dict lc))))
  264.            (look-context-set-dict!
  265.             lc
  266.             (histroy-append hist))))
  267.         ((< (length (look-context-prev lc)) look-prepared-words)
  268.          #t)
  269.         (else
  270.          (if (not (look-context-dict lc))
  271.              (look-context-set-dict!
  272.               lc
  273.               (cons (look-context-prev lc)
  274.                     (histroy-append (look-init-history look-history-stat-init))))
  275.              (if (assoc (look-context-prev lc)
  276.                         (look-context-dict lc))
  277.                  (look-context-set-dict!
  278.                   lc
  279.                   (map (lambda (x)
  280.                          (if (equal? (look-context-prev lc)
  281.                                      (car x))
  282.                              (cons (car x)
  283.                                    (histroy-append (cdr x)))
  284.                              x))
  285.                        (look-context-dict lc)))
  286.                  (look-context-set-dict!
  287.                   lc
  288.                   (append (list (cons (look-context-prev lc)
  289.                                       (histroy-append (look-init-history look-history-stat-init))))
  290.                           (look-context-dict lc)))))))
  291.   (if (< (length (look-context-prev lc)) look-prepared-words)
  292.       (look-context-set-prev! lc (append (look-context-prev lc)
  293.                                          (list (string->symbol (look-context-left lc)))))
  294.       (if (= 0 look-prepared-words)
  295.           #t
  296.           (look-context-set-prev! lc (append (cdr (look-context-prev lc))
  297.                                              (list (string->symbol (look-context-left lc))))))))
  298.  
  299. (define (look-search-learned lc str)
  300.   (if (= 0 look-prepared-words)
  301.       (if (look-context-dict lc)
  302.           (look-history-sort
  303.            (look-history-search (look-to-lower-string str)
  304.                                 (look-context-dict lc))
  305.            look-history-stat-less)
  306.           '())
  307.       (let ((res (if (look-context-dict lc)
  308.                      (assoc (look-context-prev lc) (look-context-dict lc))
  309.                      #f)))
  310.         (if res
  311.             (look-history-sort
  312.              (look-history-search (look-to-lower-string (look-context-left lc))
  313.                                   (cdr res))
  314.              look-history-stat-less)
  315.             '()))))
  316.  
  317. (define look-context-on? look-context-on)
  318. (define look-context-look? look-context-look)
  319.  
  320. (define (look-get-nth-candidate lc)
  321.   (if (< 0 (length (look-context-candidates lc)))
  322.       (nth (look-context-nth lc) (look-context-candidates lc))
  323.       ""))
  324.  
  325. (define (look-get-length-left lc)
  326.   (string-length (look-context-left lc)))
  327.  
  328. (define (look-append-left! lc str)
  329.   (look-context-set-left! lc (string-append (look-context-left lc) str)))
  330.  
  331. (define (look-remove-last-char-from-left! lc)
  332.   (let ((left (look-context-left lc)))
  333.     (if (< 0 (look-get-length-left lc))
  334.         (look-context-set-left! lc (apply string-append (reverse (cdr (string-to-list left)))))
  335.         (look-context-set-left! lc ""))))
  336.  
  337. (define (look-append-char-from-candidate-to-left! lc)
  338.   (let ((candidate (look-get-nth-candidate lc)))
  339.     (if (< 0 (string-length candidate))
  340.         (look-context-set-left! lc (string-append (look-context-left lc)
  341.                                                   (car (reverse (string-to-list candidate))))))))
  342.  
  343. (define (look-append-from-candidate-to-left! lc)
  344.   (look-context-set-left! lc (string-append (look-context-left lc)
  345.                                             (look-get-nth-candidate lc)))
  346.   (look-context-set-candidates! lc '()))
  347.  
  348. (define (look-context-new . args)
  349.   (let ((lc (apply look-context-new-internal args)))
  350.     (look-context-set-widgets! lc look-widgets)
  351.     lc))
  352.  
  353. (define (look-context-clean lc)
  354.   (look-context-set-on! lc #f)
  355.   (look-context-set-look! lc #f)
  356.   (look-context-set-nth! lc 0)
  357.   (look-context-set-candidates! lc '())
  358.   (look-context-set-left! lc ""))
  359.  
  360. (define (look-context-flush lc)
  361.   (look-learn lc)
  362.   (im-commit lc (look-context-left lc))
  363.   (look-context-set-look! lc #f)
  364.   (look-context-set-nth! lc 0)
  365.   (look-context-set-candidates! lc '())
  366.   (look-context-set-left! lc ""))
  367.  
  368. (define (look-push-back-mode lc lst)
  369.   (if (car lst)
  370.       (begin
  371.         (im-pushback-mode-list lc (caar lst))
  372.         (look-push-back-mode lc (cdr lst)))))
  373.  
  374. (define (look-init-handler id im arg)
  375.   (let ((lc (look-context-new id im)))
  376.     (look-load-personal-dict lc)
  377.     lc))
  378.  
  379. (define (look-release-handler lc)
  380.   #f)
  381.  
  382. (define (look-alphabetic-char? key state)
  383.   (and (or (not (modifier-key-mask state))
  384.            (shift-key-mask state))
  385.        (ichar-alphabetic? key)))
  386.  
  387. (define (look-next-candidate! lc)
  388.   (if (< (look-context-nth lc) (- (length (look-context-candidates lc)) 1))
  389.       (look-context-set-nth! lc (+ (look-context-nth lc) 1))))
  390.  
  391. (define (look-prev-candidate! lc)
  392.   (if (< 0 (look-context-nth lc))
  393.       (look-context-set-nth! lc (- (look-context-nth lc) 1))))
  394.  
  395. (define (look-look lc look-dict str)
  396.   (let* ((learned (look-search-learned lc str))
  397.          (looked (look-lib-look look-dict str)))
  398.     (look-context-set-dictlen! lc (length learned))
  399.     (append learned looked)))
  400.  
  401. (define (look-update lc)
  402.   (let ((str (look-context-left lc)))
  403.     (look-context-set-nth! lc 0)
  404.     (if (<= look-beginning-character-length (string-length str))
  405.         (look-context-set-candidates! lc (look-look lc look-dict str))
  406.         (look-context-set-candidates! lc '()))))
  407.  
  408. (define (look-format-candidates lc)
  409.   (let ((candidates (look-context-candidates lc)))
  410.     (if (or (= 0 (string-length (look-context-left lc)))
  411.             (<= (length candidates) (look-context-nth lc)))
  412.         ""
  413.         (string-append look-fence-left
  414.                        (nth (look-context-nth lc) candidates)
  415.                        look-fence-right))))
  416.  
  417. (define (look-format-candidates-nth lc)
  418.   (if (or (= 0 (string-length (look-context-left lc)))
  419.           (<= (length (look-context-candidates lc))
  420.               (look-context-nth lc)))
  421.       ""
  422.       (let ((nth (if (< (look-context-nth lc)
  423.                         (look-context-dictlen lc))
  424.                      (+ 1 (look-context-nth lc))
  425.                      (+ 1
  426.                         (- (look-context-nth lc)
  427.                            (look-context-dictlen lc)))))
  428.             (candidates (if (< (look-context-nth lc)
  429.                                (look-context-dictlen lc))
  430.                             (look-context-dictlen lc)
  431.                             (- (length (look-context-candidates lc))
  432.                                (look-context-dictlen lc)))))
  433.         (string-append "["
  434.                        (number->string nth)
  435.                        "/"
  436.                        (number->string candidates)
  437.                        "]"))))
  438.  
  439. (define (look-update-preedit lc)
  440.   (im-clear-preedit lc)
  441.   (im-pushback-preedit
  442.    lc preedit-none
  443.    (look-context-left lc))
  444.   (im-pushback-preedit
  445.    lc preedit-cursor
  446.    (look-format-candidates lc))
  447.   (if (< (look-context-nth lc) (look-context-dictlen lc))
  448.       (im-pushback-preedit
  449.        lc preedit-none
  450.        (look-format-candidates-nth lc))
  451.       (im-pushback-preedit
  452.        lc preedit-reverse
  453.        (look-format-candidates-nth lc)))
  454.   (im-update-preedit lc))
  455.  
  456. (define (look-key-press-state-look lc key state)
  457.   (cond ((look-off-key? key state)
  458.          (look-context-clean lc)
  459.          (look-update-preedit lc))
  460.         ((look-alphabetic-char? key state)
  461.          (look-append-left! lc (charcode->string key))
  462.          (look-update lc)
  463.          (look-update-preedit lc))
  464.         ((look-completion-key? key state)
  465.          (look-append-from-candidate-to-left! lc)
  466.          (look-context-flush lc)
  467.          (look-update-preedit lc))
  468.         ((and (look-next-char-key? key state)
  469.               (< 0 (look-get-length-left lc)))
  470.          (look-append-char-from-candidate-to-left! lc)
  471.          (look-update lc)
  472.          (look-update-preedit lc))
  473.         ((look-prev-char-key? key state)
  474.          (cond ((<= (look-get-length-left lc) 0)
  475.                 (look-context-flush lc)
  476.                 ;; or (look-context-clean lc)
  477.         (im-commit-raw lc))
  478.                (else
  479.                 (look-remove-last-char-from-left! lc)))
  480.          (look-update lc)
  481.          (look-update-preedit lc))
  482.         ((look-next-candidate-key? key state)
  483.          (look-next-candidate! lc)
  484.          (look-update-preedit lc))
  485.         ((look-prev-candidate-key? key state)
  486.          (look-prev-candidate! lc)
  487.          (look-update-preedit lc))
  488.         ((look-save-dict-key? key state)
  489.          (look-save-personal-dict lc)
  490.          (im-commit-raw lc)
  491.          (look-context-flush lc)
  492.          (look-update-preedit lc))
  493.         ((look-load-dict-key? key state)
  494.          (look-load-personal-dict lc)
  495.          (im-commit-raw lc)
  496.          (look-context-flush lc)
  497.          (look-update-preedit lc))
  498.         (else
  499.          (im-commit-raw lc)
  500.          (look-context-flush lc)
  501.          (look-update-preedit lc))))
  502.  
  503. (define (look-key-press-state-direct lc key state)
  504.   (cond ((look-off-key? key state)
  505.          (look-context-clean lc)
  506.          (look-update-preedit lc))
  507.         ((look-alphabetic-char? key state)
  508.          (look-context-set-left! lc (charcode->string key))
  509.          (look-update lc)
  510.          (look-update-preedit lc)
  511.          (look-context-set-look! lc #t))
  512.         ((look-save-dict-key? key state)
  513.          (look-save-personal-dict lc)
  514.          (im-commit-raw lc))
  515.         ((look-load-dict-key? key state)
  516.          (look-load-personal-dict lc)
  517.          (im-commit-raw lc))
  518.         (else
  519.          (im-commit-raw lc))))
  520.  
  521. (define (look-key-press-state-sleep lc key state)
  522.   (cond ((look-on-key? key state)
  523.          (look-context-set-on! lc #t)
  524.          (look-context-set-look! lc #f))
  525.         (else
  526.          (im-commit-raw lc))))
  527.  
  528. (define (look-key-press-handler lc key state)
  529.   (if (look-context-on? lc)
  530.       (if (look-context-look? lc)
  531.           (look-key-press-state-look lc key state)
  532.           (look-key-press-state-direct lc key state))
  533.       (look-key-press-state-sleep lc key state)))
  534.  
  535. (define (look-key-release-handler lc key state)
  536.   (im-commit-raw lc))
  537.  
  538. (define (look-reset-handler lc)
  539.   #f)
  540.  
  541. ;;(define (look-mode-handler lc mode)
  542. ;;  (create-context (look-context-id lc)
  543. ;;                  #f
  544. ;;                  (car (nth mode im-list)))
  545. ;;  #f)
  546.  
  547. (define (look-get-candidate-handler lc idx)
  548.   #f)
  549.  
  550. (define (look-set-candidate-index-handler lc idx)
  551.   #f)
  552.  
  553. (look-configure-widgets)
  554.  
  555. (register-im
  556.  'look
  557.  "*"  ;; wildcard language. see i18n.scm
  558.  "UTF-8"
  559.  (N_ "Look")
  560.  (N_ "Tiny predictive input method")
  561.  #f
  562.  look-init-handler
  563.  look-release-handler
  564.  context-mode-handler
  565.  look-key-press-handler
  566.  look-key-release-handler
  567.  look-reset-handler
  568.  look-get-candidate-handler
  569.  look-set-candidate-index-handler
  570.  context-prop-activate-handler
  571.  #f
  572.  #f
  573.  #f
  574.  #f
  575.  #f
  576.  )
  577.